home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
hcdemo.zip
/
PRNTSCR.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
15KB
|
447 lines
unit prntscr;
interface
uses dos,crt,printer,graph;
{$V-}
{$R-} {Range checking off}
{$B+} {Boolean complete evaluation on}
{$S+} {Stack checking on}
{$I+} {I/O checking on}
const XMaxGlb =79; { Number of BYTES -1 in one screen line }
IVStepGlb= 2; { Initial value of VStepGlb }
var
XScreenMaxGlb, XPrnMax, YMaxGlb : Integer;
procedure SetBinBit;
procedure UnSetBinBit;
procedure dump_buffer;
procedure Okidata_hardcopy(inverse:boolean;mode,start:byte); { Okidata }
procedure OkiHrdCpySide(inverse:boolean;mode,start:byte);
procedure Epson_hardcopy(inverse:boolean;mode,start:byte); { EPSON }
procedure EpsHrdCpySide(inverse:boolean;mode,start:byte);
Procedure ProHrdCpySide(Inverse:Boolean;Mode,start: Byte );
procedure proprnt_hardcopy(inverse:boolean;mode,start:byte); { IBM }
procedure hardcopy(inverse:boolean;mode:byte;PrnType,
Start:integer;Upright:Boolean);
implementation
procedure SetBinBit;
{ Sets the binary bit on the Lst device so data is passed }
{ in "raw" binary mode instead of ASCII mode through Lst. }
var
LstHandle : word absolute Lst;
Regs : Registers;
begin
with Regs do
begin
AX := $4400; { IOCTL sub function 0 - Get device information }
BX := LstHandle; { device information is returned in DX }
MsDos(Regs);
AX := $4401; { IOCTL sub function 1 - Set device information }
{ New device setting is passed in DX }
DX := (DX and $00FF) or $0020; { Set bit 5 of DX so data is passed }
{ in "raw" mode through the Lst device }
MsDos(Regs);
end;
end; { SetBinBit }
procedure UnSetBinBit;
{ UnSets the binary bit on the Lst device so data is passed }
{ in "cooked" ASCII mode instead of binary mode through Lst. }
Var
LstHandle : word absolute Lst;
Regs : Registers;
begin
with Regs do
begin
AX := $4400; { IOCTL sub function 0 - Get device information }
BX := LstHandle; { device information is returned in DX }
MsDos(Regs);
AX := $4401; { IOCTL sub function 1 - Set device information }
{ New device setting is passed in DX }
DX := (DX and $00FF) xor $0020; { Turn bit 5 of DX off so data is passed }
{ in "cooked" mode through the Lst device}
MsDos(Regs);
end;
end; { UnSetBinBit }
procedure dump_buffer;
{ For use on IBM PC-LAN System. }
var
regs : registers;
begin
with regs do
begin
ah := 6;
al := 3;
intr($2a,regs);
end;
end;
procedure Okidata_hardcopy;
var i,j,top,row:integer;
ColorLoc,PrintByte:byte;
procedure doline(top:integer);
var j : integer;
function ConstructByte(j,i:integer):byte;
{ The image is reversed for Okidata, and only 7 bits are used. }
const Bits:array [0..6] of byte=(1,2,4,8,16,32,64);
var CByte,k:byte;
begin
i:=i * 7;
CByte:=0;
for k:=0 to 6 do
if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
Cbyte := Cbyte or 128;
ConstructByte:=CByte;
end;
begin
SetBinBit;
for j:=0 to XScreenMaxGlb do
begin
if keypressed then exit else
PrintByte:=ConstructByte(j,i);
Write(lst,chr(PrintByte));
if (j-1) mod 5 = 0 then
Write(lst,chr(PrintByte));
end;
Write(lst,#3,#14); { Graphics Cr + Lf }
end;
begin
top:=7;
row := GetMaxY div 7;
mode:=mode and 7;
if (mode=5) or (mode=0) then mode:=4;
if start = 0 then
begin
Write(lst,#29); { 17 CPI }
Write(lst,#27,'1'); { Correspondence Quality }
Write(lst,#27,'0'); { Reset to default lines per inch }
Write(lst,#27,'8'); { 8 lines per inch }
Write(lst,#27,'N',#3); { Spacing }
end;
Write(lst,#3); { Okidata Graphics Mode. }
for i:= 0 to row do { Print line of graphics. }
doline(6);
Write(lst,#3,#2); { Exit Graphics Mode. }
Write(lst,#29,'%9',#0); { Normal height print. }
Write(lst,#30); { Normal print width. }
end;
Procedure OkiHrdCpySide; { Sideways print }
Var Row, Col, G_row : Integer ;
ColorLoc, PrintByte : Byte ;
LCnt, HCnt : Char ; { number of data points }
NumOfDots,
Rpt, Mult : Integer ; { scan multiplier }
Function ConstructByte( X, Y : Integer ) : Byte ;
const Bits:array [0..6] of byte=(1,2,4,8,16,32,64);
Var CByte, B : Byte ;
Begin
G_row := GetMaxX div 7;
CByte := 0 ; X := X * 7;
For B := 0 To 6 Do If GetPixel( X + B, Y ) > 0 Then
CByte := CByte OR Bits[B] ;
CByte := CByte OR 128;
ConstructByte := CByte ;
End ;
Begin
Mult := 2;
Write(lst,#27,'0'); { Reset to default lines per inch }
Write(lst,#27,'1'); { Correspondence Quality }
Write(lst,#27,'8'); { 8 lines per inch }
Write(lst,#29); { 17 CPI }
Write(lst,#3); { Okidata Graphics Mode. }
For Col := 0 To XMaxGlb Do
Begin
SetBinBit;
For Row := GetMaxY - 1 DownTo 0 Do
Begin
PrintByte := ConstructByte( Col, Row ) ; { The byte to send }
For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
End ;
Write(lst,#3,#14);
End ;
WRite(lst,#3,#14);
Write(lst,#3,#2);
Write(lst,#29,'%9',#0); { Normal height print. }
Write(lst,#30); { Normal print width. }
End ;
procedure Epson_hardcopy;
var i,j,top:integer;
ColorLoc,PrintByte:byte;
procedure doline(top:integer);
var j : integer;
function ConstructByte(j,i:integer):byte;
const Bits:array [0..7] of byte=(128,64,32,16,8,4,2,1);
var CByte,k:byte;
begin
i:=i shl 3;
CByte:=0;
for k:=0 to top do
if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
ConstructByte:=CByte;
end;
begin
if mode=1 then Write(lst,^['L')
else Write(lst,^['*',chr(mode));
Write(lst,chr(lo(XScreenMaxGlb+1)),chr(Hi(XScreenMaxGlb+215)));
for j:=0 to XScreenMaxGlb do
begin
if keypressed then exit else
PrintByte:=ConstructByte(j,i);
Write(lst,chr(PrintByte));
if (mode=1) and ((j-1) mod 3 = 0) then
Write(lst,chr(PrintByte));
end;
if mode<>4 then Writeln(lst);
end;
begin
top:=7;
mode:=mode and 7;
if (mode=5) or (mode=0) then mode:=4;
Write(lst,^['3'#24);
for i:= 0 to ((YMaxGlb) shr 3)-1 do doline(7);
i:=((YMaxGlb) shr 3);
if (YMaxGlb) and 7<>0 then
doline((YMaxGlb) and 7);
end;
Procedure EPSHrdCpySide;
Var Row, Col : Integer ;
ColorLoc, PrintByte : Byte ;
LCnt, HCnt : Char ; { number of data points }
NumOfDots,
LeftMargin,
Rpt, Mult : Integer ; { scan multiplier }
Function ConstructByte( X, Y : Integer ) : Byte ;
Const Bits : Array [0..7] Of Byte = ( 128, 64, 32, 16, 8, 4, 2, 1 ) ;
Var CByte, B : Byte ;
Begin
CByte := 0 ; X := X SHL 3 ;
For B := 0 To 7 Do If GetPixel( X + B, Y ) > 0 Then
CByte := CByte OR Bits[B] ;
ConstructByte := CByte ;
End ;
Begin
Mult := 2;
LeftMargin := 5; { One inch for left margin }
Write(lst,^['3'#24);
Write( LST, ^J^J^J^J ) ; { To center image for CGA }
NumOfDots := GetMaxY * Mult ; { Compute how many }
LCnt := Chr( Lo( NumOfDots )) ; { dots/line we are }
HCnt := Chr( Hi( NumOfDots )) ; { going to send. }
For Col := 0 To XMaxGlb Do
Begin
if mode=1 then Write(lst,^['L')
else Write(lst,^['*',chr(mode));
Write( LST, LCnt, HCnt ) ; { Dot count to send }
For Row := GetMaxY - 1 DownTo 0 Do
Begin
PrintByte := ConstructByte( Col, Row ) ; { The byte to send }
If Inverse Then PrintByte := NOT PrintByte ; { Set reverse video }
For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
End ;
WriteLn( LST ) ;
End ;
End ;
Procedure ProHrdCpySide;
Const G480 = 0 ; { 60 dpi, 480 dpl } { <-- disabled for HGC }
G960a = 1 ; { 120 dpi, 960 dpl }
G960b = 2 ; { 120 dpi, 960 dpl } { <-- disabled for CGA and HGC }
G1920 = 3 ; { 240 dpi, 1920 dpl } { <-- disabled for CGA and HGC }
LineSpc08 = ^['A'#8 ; { set line feed to 8/72" }
LineSpc12 = ^['A'#12 ; { set line feed to 1/6" }
StartVLF = ^['2' ; { start variable line feed }
FormFeed = #12 ; { form feed }
Start480 = ^['K' ; { start 480 dots / line }
Start960a = ^['L' ; { start 960a dots / line }
Start960b = ^['Y' ; { start 960b dots / line }
Start1920 = ^['Z' ; { start 1920 dots / line }
Var Row, Col : Integer ;
ColorLoc, PrintByte : Byte ;
LCnt, HCnt : Char ; { number of data points }
NumOfDots,
LeftMargin,
Rpt, Mult : Integer ; { scan multiplier }
Function ConstructByte( X, Y : Integer ) : Byte ;
Const Bits : Array [0..7] Of Byte = ( 128, 64, 32, 16, 8, 4, 2, 1 ) ;
Var CByte, B : Byte ;
Begin
CByte := 0 ; X := X SHL 3 ; { See KERNEL.DOC for desc of PD }
For B := 0 To 7 Do If GetPixel( X + B, Y ) > 0 Then
CByte := CByte OR Bits[B] ;
ConstructByte := CByte ;
End ;
Begin
If Mode < G480 { Make sure Mode is bounded }
Then Mode := G480 { between 0 and 3 }
Else If Mode > G1920
Then Mode := G1920 ;
Mult := 2 ; { Lets send each pixel twice }
LeftMargin := 10; { Two inches for left margin }
Write( LST, ^J^J^J^J ) ; { To center image for CGA }
Write( LST, LineSpc08 ) ; { set line spacing 8/72" }
Write( LST, StartVLF ) ; { start variable line feed }
NumOfDots := ( YMaxGlb + 1 + LeftMargin ) * Mult ; { Compute how many }
LCnt := Chr( Lo( NumOfDots )) ; { dots/line we are }
HCnt := Chr( Hi( NumOfDots )) ; { going to send. }
For Col := 0 To XMaxGlb Do { XMaxGlb def in TYPEDEF.SYS }
Begin
Case Mode Of
G960a, { start 960a dots / line }
G960b, { start 960b dots / line }
G1920 : Write( LST, Start960a ) ; { start 1920 dots / line }
End ;
Write( LST, LCnt, HCnt ) ; { Dot count to send }
For Row := 1 To LeftMargin * Mult Do
Write( LST, ^@ ) ; { Put the Left margin }
For Row := YMaxGlb DownTo 0 Do { YMaxGlb def in TYPEDEF.SYS }
Begin
PrintByte := ConstructByte( Col, Row ) ; { The byte to send }
If Inverse Then PrintByte := NOT PrintByte ; { Set reverse video }
For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
End ;
WriteLn( LST ) ;
End ;
Write( LST, LineSpc12 ) ; { reset line spacing 12/72" }
Write( LST, StartVLF ) ; { start variable line feed }
End ;
procedure proprnt_hardcopy;
const
Start480 = ^['K' ; { start 480 dots / line }
Start960a = ^['L' ; { start 960a dots / line }
Start960b = ^['Y' ; { start 960b dots / line }
Start1920 = ^['Z' ; { start 1920 dots / line }
var i,j,top:integer;
PrintByte:byte;
procedure doline(top:integer);
var j : integer;
function ConstructByte(j,i:integer):byte;
const Bits:array [0..7] of byte=(128,64,32,16,8,4,2,1);
var CByte,k:byte;
begin
i:=i shl 3;
CByte:=0;
for k:=0 to top do
if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
ConstructByte:=CByte;
end;
begin
case mode of { Send IBM Proprinter codes. }
1 : Write(lst,Start480);
2 : Write(lst,Start960a);
3 : Write(lst,Start960b);
4 : Write(lst,Start1920);
end; { Case }
Write(lst,chr(lo(XPrnMax)),chr(Hi(XPrnMax)));
for j:=0 to XScreenMaxGlb do
begin
PrintByte:=ConstructByte(j,i);
if inverse then PrintByte:=not PrintByte;
if mode in [1..3] then
begin
if keypressed then exit else
Write(lst,chr(PrintByte));
if ((j-1) mod 4 = 0) and
(mode in [2,3]) then
Write(lst,chr(PrintByte)); { Extend horizontal size }
end else
begin
if keypressed then exit else
Write(lst,chr(PrintByte));
end;
end; { j }
if mode<>4 then Writeln(lst);
end;
begin
top:=7;
mode:=mode and 7;
if (mode=5) or (mode=0) then mode:=4;
Write(lst,^['3'#24);
Writeln(lst,^['X'#1,#255);
for i:= 0 to ((YMaxGlb) shr 3)-1 do doline(7);
i:=((YMaxGlb) shr 3);
if (YMaxGlb) and 7<>0 then
doline((YMaxGlb) and 7);
end;
procedure hardcopy;
Var
GraphDriver, GraphMode, i : Integer;
begin
XScreenMaxGlb := GetMaxX - 1; { Max number of PIXELS across screen. }
YMaxGlb := GetMaxY - 1; { Max number of PIXELS down screen. }
XPrnMax := 815; { Max Proprinter PIXEL width. }
SetBinBit; { Set LST device for binary data }
case PrnType of
1: if Upright then ProPrnt_hardcopy(inverse,mode,Start)
else
ProHrdCpySide(inverse,mode,start);
2: if Upright then Epson_HardCopy(inverse,mode,start)
else
EpsHrdCpySide(inverse,mode,Start);
3: if Upright then okidata_hardcopy(inverse,mode,Start)
else
OkiHrdCpySide(inverse,mode,Start);
end; { Case }
UnSetBinBit;
Dump_Buffer; { For Network Use }
end;
end.